home *** CD-ROM | disk | FTP | other *** search
- ;;;; DEFSYSTEM.LSP
- ;;;;
- ;;;; --- System Generation Tool for Kyoto Common Lisp ---
-
-
- (in-package 'lisp)
- (export '(defsystem defkcl defkcn))
- (in-package 'compiler)
- (in-package 'system)
-
- ;;; *KCL-HOME-DIRECTORY*
- (defvar *kcl-home-directory* #"^") ; Change!!
- ;(defvar *kcl-home-directory* #"../") ; Change!!
-
-
- (defvar *port-directory*
- (make-pathname :directory (append (pathname-directory
- *kcl-home-directory*)
- (list #+aosvs "port"
- #+unix "unixport"))
- :name nil :type nil))
- (defvar *lsp-directory*
- (make-pathname :directory (append (pathname-directory
- *kcl-home-directory*)
- (list "lsp"))
- :name nil :type nil))
- #+unix
- (defvar *include.h*
- (make-pathname :directory (append (pathname-directory
- *kcl-home-directory*)
- (list "h"))
- :name "include" :type "h"))
- (defvar *ob-directory*
- (make-pathname :directory (append (pathname-directory
- *kcl-home-directory*)
- (list #+aosvs "ob" #+unix "o"))
- :name nil :type nil))
-
-
- (setq *print-case* :downcase)
-
-
- (defvar *object-files*
- #+aosvs
- '("main" "alloc" "gbc"
- "ffalt" "short" "interrupt"
- "eval" "macros" "frame" "error" "reference" "assignment"
- "conditional" "catch" "lex" "prog" "block" "bds"
- "multival" "mapfun" "let" "iteration" "toplevel" "cmpaux"
- "array" "bind" "cfun" "character" "file" "list"
- "pathname" "package" "predicate" "print" "read" "backq"
- "structure" "sequence" "string" "symbol" "typespec"
- "big" "number" "num_arith" "num_co" "num_comp" "num_sfun" "num_log"
- "num_pred" "num_rand" "earith"
- "hash" "filesystem" "time"
- "fasl_loader" "fasl_pass1" "fasl_pass2" "fasl_reloc" "fasl_table"
- "fasl_io" "fasload"
- "bitop"
- "savemem" "sys"
- "process"
- "format")
- #+unix
- '("main" "alloc" "gbc"
- "bitop"
- "typespec"
- "eval" "macros" "lex" "bds" "frame"
- "predicate"
- "reference" "assignment" "bind" "let"
- "conditional" "block" "iteration" "mapfun"
- "prog" "multival" "catch"
- "symbol" "cfun" "cmpaux" "package"
- "big" "number" "num_pred" "num_comp" "num_arith" "num_sfun"
- "num_co" "num_log" "num_rand" "earith"
- "character" "char_table"
- "sequence" "list" "hash" "array" "string" "structure"
- "toplevel"
- "file" "read" "backq" "print" "format" "pathname" "unixfsys"
- "unixfasl"
- "error"
- "unixtime" "unixsys" "unixsave" "unixint"))
-
- (defvar *lsp-object-files*
- '("defmacro" "evalmacros" "top" "module"))
-
- (defvar *all-libraries*
- '("predlib" "setf"
- "arraylib" "assert" "defstruct" "describe"
- "iolib" "listlib" "mislib" "numlib"
- "packlib" "seq" "seqlib" "trace"))
-
-
- (defun change-file-type (file type)
- (make-pathname :directory (pathname-directory file)
- :name (pathname-name file)
- :type type))
-
- (defun strip-file-type (file) (change-file-type file nil))
-
- (defun search-tree (x tree)
- (loop
- (cond ((equal x tree) (return t))
- ((atom tree) (return nil))
- ((search-tree x (car tree)) (return t))
- (t (setq tree (cdr tree))))))
-
-
- (defmacro defsystem (system-name files &rest body)
- (if (atom system-name)
- `(make-system ',system-name ',files ',body)
- `(apply #'make-system
- ',(car system-name) ',files ',body
- ',(cdr system-name))))
-
- (defun make-system (system-name files initial-forms
- &key (libraries nil)
- (system system-name)
- (raw-system
- (merge-pathnames
- (format nil "raw_~A" system-name)
- system))
- (top-level nil)
- (command-file
- (format nil
- #+aosvs "make_~A.cli" #+unix "make_~A"
- system-name))
- (sys-file
- (format nil "sys_~A.c" system-name))
- (init-file
- (format nil "init_~A.lsp" system-name))
- #+aosvs (use-console t))
-
- #+aosvs (setq system (change-file-type system "pr"))
- #+aosvs (setq raw-system (change-file-type raw-system "pr"))
-
- (cond ((eq libraries t) (setq libraries *all-libraries*))
- (t
- (dolist (library libraries)
- (unless (member (string library) *all-libraries*
- :test #'string-equal)
- (error "~S is not a library." library)))
- ;; Reorder the libraries.
- (setq libraries
- (mapcan #'(lambda (library)
- (if (member library libraries
- :test #'string-equal :key #'string)
- (list library)
- nil))
- *all-libraries*))))
-
- (setq files
- (mapcar #'(lambda (file)
- (if (symbolp file)
- (string-downcase (symbol-name file))
- file))
- files))
-
- (when (symbolp system)
- (setq system (string-downcase (symbol-name system))))
- (when (symbolp raw-system)
- (setq raw-system (string-downcase (symbol-name raw-system))))
-
- (unless (search-tree 'si:init-system initial-forms)
- (setq initial-forms
- (append initial-forms (list '(si:init-system)))))
-
- (when top-level
- (setq initial-forms
- (append initial-forms
- (list `(defun si:top-level () (,top-level))))))
-
- ;; Make the sys file.
- (setq sys-file (change-file-type sys-file "c"))
- (with-open-file (stream sys-file :direction :output)
- #+unix
- (format stream "#include \"~A\"~%~%" (namestring *include.h*))
- #+aosvs
- (format stream "#include \"include.h\"~%~%")
- (format stream "static object fasl_data;~%~%")
- (format stream "init_init()~%{~%")
- (format stream " enter_mark_origin(&fasl_data);~%")
- (format stream " fasl_data = Cnil;~%~%")
- (format stream " load(\"~A\");~%"
- (namestring (merge-pathnames "export.lsp" *lsp-directory*)))
- (dolist (library *lsp-object-files*)
- (format stream
- " fasl_data = read_fasl_data(\"~A\");~%"
- (namestring
- (merge-pathnames (change-file-type library
- #+aosvs "fasl" #+unix "o")
- *lsp-directory*)))
- (format stream " init_~A(NULL, 0, fasl_data);~%" library))
- (format stream " load(\"~A\");~%"
- (namestring (merge-pathnames "autoload.lsp" *lsp-directory*)))
- (format stream "}~%~%")
- (format stream "init_system()~%{~%")
- (dolist (library libraries)
- (format stream
- " printf(\"Initializing ~A... \"); fflush(stdout);~%"
- library)
- (format stream
- " fasl_data = read_fasl_data(\"~A\");~%"
- (namestring
- (merge-pathnames (change-file-type library
- #+aosvs "fasl" #+unix "o")
- *lsp-directory*)))
- (format stream " init_~A(NULL, 0, fasl_data);~%" library)
- (format stream
- " printf(\"\\n\"); fflush(stdout);~%"))
- (format stream "~%")
- (dolist (file files)
- (format stream
- " printf(\"Initializing ~A... \"); fflush(stdout);~%"
- (pathname-name file))
- (format stream
- " Vpackage->s.s_dbind = user_package;~%")
- (format stream
- " fasl_data = read_fasl_data(\"~A\");~%"
- (namestring
- (change-file-type file #+aosvs "fasl" #+unix "o")))
- (format stream " init_~A(NULL, 0, fasl_data);~%"
- (string-downcase (pathname-name file)))
- (format stream
- " printf(\"\\n\"); fflush(stdout);~%"))
- (format stream
- "~% Vpackage->s.s_dbind = user_package;~%")
- (format stream "}~%"))
-
- ;; Make the init file.
- (with-open-file (stream init-file :direction :output)
- (mapcar #'(lambda (package)
- (unless (eq package (find-package 'keyword))
- (prin1 `(IN-PACKAGE ,(package-name package)) stream)
- (terpri stream)))
- (list-all-packages))
- (prin1 `(IN-PACKAGE ,(package-name *package*)) stream)
- (terpri stream)
- (prin1 (if #+aosvs use-console #+unix t
- #+aosvs
- `(PROGN
- ,@initial-forms
- (FORMAT T "~&~%Type in (SAVE \"~A\") and (BYE).~%~%"
- ,(namestring (strip-file-type system))))
- `(PROGN
- ,@initial-forms
- (SAVE ,(namestring (strip-file-type system)))
- (BYE)))
- stream)
- (terpri stream))
-
- ;; Make the command file.
- (with-open-file (stream command-file :direction :output)
-
- #+aosvs
- ;; Set the search list.
- (format stream
- "push;prompt pop~%~%~
- searchlist :USR:DGC :UTIL ~A~%~%"
- (namestring (make-pathname
- :directory
- (pathname-directory *kcl-home-directory*)
- :name "h")))
-
- #+aosvs
- ;; Change the current directory.
- (format stream "directory ~A~%~%" (namestring (truename "=")))
-
- ;; Compile the sys file.
- (format stream
- #+aosvs
- "write Compiling ~A~%~
- cc/opt=2/nomap/noinclude/noextl &~%~
- AOSVS/define MAXPAGE/define=2048 VSSIZE/define=2048 &~%~
- ~A~%~%"
- #+unix
- "#~%~%~
- if ({ vax }) then~%~
- set MACHINE = VAX~%~
- endif~%~%~
- if ({ sun }) then~%~
- set MACHINE = SUN~%~
- endif~%~%~
- echo Compiling ~A~%~
- cc -c -D$MACHINE -DMAXPAGE=2048 -DVSSIZE=2048 ~A~%~%"
- (namestring sys-file)
- #+aosvs (namestring (strip-file-type sys-file))
- #+unix (namestring sys-file))
-
- ;; Link the raw system.
- #+aosvs
- (format stream
- #+aosvs
- "write Linking~%~
- ccl/storage=131072/task=2/mtop=34/nounx/o=~A &~%~
- ~{~A ~}&~%~
- ~A &~%~
- ~{~A ~}&~%~
- ~{~A ~}~%~%"
- (namestring (strip-file-type raw-system))
- (mapcar #'(lambda (object-file)
- (namestring
- (strip-file-type
- (merge-pathnames object-file *ob-directory*))))
- *object-files*)
- (namestring (strip-file-type sys-file))
- (mapcar #'(lambda (library)
- (namestring
- (merge-pathnames library *lsp-directory*)))
- (append *lsp-object-files* libraries))
- (mapcar #'(lambda (file) (namestring (strip-file-type file)))
- files))
- #+unix
- (format stream
- "echo Linking~%~
- cc -o ~A \\~%~
- ~{~A ~}\\~%~
- ~A \\~%~
- ~{~A ~}\\~%~
- ~{~A ~}\\~%~
- -lm ~%~%"
- (namestring raw-system)
- (mapcar #'(lambda (object-file)
- (namestring
- (change-file-type
- (merge-pathnames object-file *ob-directory*)
- "o")))
- *object-files*)
- (namestring (change-file-type sys-file "o"))
- (mapcar #'(lambda (library)
- (namestring
- (change-file-type
- (merge-pathnames library *lsp-directory*)
- "o")))
- (append *lsp-object-files* libraries))
- (mapcar #'(lambda (file)
- (namestring (change-file-type file "o")))
- files))
-
- ;; Save the system.
- #+aosvs
- (if (not use-console)
- (format stream
- "process/default/block/ioc/priority=3/input=~A &~%~
- ~A ~A~%~%"
- (namestring init-file)
- (namestring (strip-file-type raw-system))
- (namestring *port-directory*))
- (format stream "write Invoke ~A and load ~A."
- (namestring (strip-file-type raw-system))
- (namestring init-file)))
- #+unix
- (format stream
- "~A ~A < ~A~%~%"
- (namestring raw-system)
- (namestring *port-directory*)
- (namestring init-file)))
-
- (format t "Command file is ~A.~%" (namestring command-file))
- )
-
-
- (defvar *cmpnew-directory*
- (make-pathname :directory (append (pathname-directory
- *kcl-home-directory*)
- (list "cmpnew"))
- :name nil :type nil))
-
-
- (defvar *lisp-implementation-version*
- (multiple-value-bind (sec min hour date month year)
- (get-decoded-time)
- (format nil "~A ~D, ~D"
- (case month
- (1 "January") (2 "Feburary") (3 "March")
- (4 "April") (5 "May") (6 "June")
- (7 "July") (8 "August") (9 "September")
- (10 "October") (11 "November") (12 "December"))
- date year)))
-
-
- (defmacro defkcl (&key (system-name "kcl")
- #+aosvs
- (system system-name)
- #+unix
- (system (format nil "saved_~a" (string system-name)))
- (raw-system (format nil "raw_~a" (string system-name)))
- (include-compiler t)
- (libraries t)
- &aux (*package* *package*)
- )
-
- (in-package 'system)
- (setq *check-time* nil)
-
- `(defsystem (,system-name
- :top-level kcl-top-level
- :libraries ,libraries
- :system ,system
- :raw-system ,raw-system
- #+aosvs :use-console #+aosvs t)
-
- ,(if include-compiler
- (list (merge-pathnames "cmpinline" *cmpnew-directory*)
- (merge-pathnames "cmputil" *cmpnew-directory*)
- (merge-pathnames "cmptype" *cmpnew-directory*)
- (merge-pathnames "cmpbind" *cmpnew-directory*)
- (merge-pathnames "cmpblock" *cmpnew-directory*)
- (merge-pathnames "cmpcall" *cmpnew-directory*)
- (merge-pathnames "cmpcatch" *cmpnew-directory*)
- (merge-pathnames "cmpenv" *cmpnew-directory*)
- (merge-pathnames "cmpeval" *cmpnew-directory*)
- (merge-pathnames "cmpflet" *cmpnew-directory*)
- (merge-pathnames "cmpfun" *cmpnew-directory*)
- (merge-pathnames "cmpif" *cmpnew-directory*)
- (merge-pathnames "cmplabel" *cmpnew-directory*)
- (merge-pathnames "cmplam" *cmpnew-directory*)
- (merge-pathnames "cmplet" *cmpnew-directory*)
- (merge-pathnames "cmploc" *cmpnew-directory*)
- ;(merge-pathnames "cmpmain" *cmpnew-directory*)
- (merge-pathnames "cmpmap" *cmpnew-directory*)
- (merge-pathnames "cmpmulti" *cmpnew-directory*)
- (merge-pathnames "cmpspecial" *cmpnew-directory*)
- (merge-pathnames "cmptag" *cmpnew-directory*)
- (merge-pathnames "cmptop" *cmpnew-directory*)
- (merge-pathnames "cmpvar" *cmpnew-directory*)
- (merge-pathnames "cmpvs" *cmpnew-directory*)
- (merge-pathnames "cmpwt" *cmpnew-directory*))
- nil)
-
- (allocate 'cons 90)
-
- (si:init-system)
-
- (gbc t)
-
- ,@(if include-compiler
- `((load ,(merge-pathnames "cmpmain.lsp" *cmpnew-directory*))
- (gbc t)
- (load ,(merge-pathnames "lfun_list.lsp" *cmpnew-directory*))
- (gbc t)
- (load ,(merge-pathnames "cmpopt.lsp" *cmpnew-directory*))
- (gbc t)
- (defun compile-file (&rest args
- &aux (*print-pretty* nil)
- (*package* *package*))
- (compiler::init-env)
- (apply 'compiler::compile-file1 args))
- (defun compile (&rest args &aux (*print-pretty* nil))
- (apply 'compiler::compile1 args))
- (defun disassemble (&rest args &aux (*print-pretty* nil))
- (apply 'compiler::disassemble1 args)))
- nil)
-
- (setq *old-top-level* (symbol-function 'si:top-level))
-
- (defun kcl-top-level ()
-
- (when (> (si:argc) 1) (setq *system-directory* (si:argv 1)))
-
- ,@(if include-compiler
- '((when (>= (si:argc) 5)
- (let ((si::*quit-tag* (cons nil nil))
- (si::*quit-tags* nil)
- (si::*break-level* 0)
- (si::*break-env* nil)
- (si::*ihs-base* 1)
- (si::*ihs-top* 1)
- (si::*current-ihs* 1)
- (*break-enable* nil))
- (si:error-set
- '(let ((flags (si:argv 4)))
- (setq si:*system-directory* (pathname (si:argv 1)))
- (compile-file
- (si:argv 2)
- :output-file (si:argv 3)
- #+unix :o-file
- #+aosvs :fasl-file
- (case (schar flags 1)
- (#\0 nil) (#\1 t) (t (si:argv 5)))
- :c-file
- (case (schar flags 2)
- (#\0 nil) (#\1 t) (t (si:argv 6)))
- :h-file
- (case (schar flags 3)
- (#\0 nil) (#\1 t) (t (si:argv 7)))
- :data-file
- (case (schar flags 4)
- (#\0 nil) (#\1 t) (t (si:argv 8)))
- #+aosvs :ob-file
- #+aosvs
- (case (schar flags 5)
- (#\0 nil) (#\1 t) (t (si:argv 9)))
- :system-p
- (if (char-equal (schar flags 0) #\S) t nil))))
- (bye))))
- nil)
-
- (format t "KCl (Kyoto Common Lisp) ~A~%"
- ,*lisp-implementation-version*)
-
- (in-package 'user)
-
- (funcall *old-top-level*))
-
- (defun lisp-implementation-version () ,*lisp-implementation-version*)
-
- (setq *modules* nil)
-
- (gbc t)
-
- (si:reset-gbc-count)
-
- (allocate 'cons 200)
-
- #+unix (defun si:top-level () (kcl-top-level))
-
- #+unix (si:save-system ,system)
- #+unix (bye)
-
- #+aosvs (format t "~%Use SI:SAVE-SYSTEM instead of SAVE.~%")
-
- )
- )
-
- (defmacro defkcn (&rest r)
- `(defkcl :include-compiler nil
- :system-name kcn
- ,@r))
-